home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 18 / CU Amiga Magazine's Super CD-ROM 18 (1997)(EMAP Images)(GB)[!][issue 1998-01].iso / CUCD / Programming / AmigaE / Src / Lang / Forth.e < prev    next >
Text File  |  1992-09-02  |  4KB  |  126 lines
  1. /* TinyForth, a subset Forth interpreter
  2.    no functions *yet*, so may be used as funny calculator
  3.    with stack. exits on QUIT<cr> or <ctrlc><cr> */
  4.  
  5. CONST MAXSTACK=1000,MAXRSTACK=200
  6. ENUM NO_MES,OK,ER_UNDERFLOW,ER_OVERFLOW,ER_SYM
  7.  
  8. DEF con=NIL,stop=FALSE,error=OK,crflag=TRUE,
  9.     inp[100]:STRING,
  10.     item[50]:STRING, item2[50]:STRING,
  11.     stack[MAXSTACK]:ARRAY OF LONG, rstack[MAXRSTACK]:ARRAY OF LONG,
  12.     sp:PTR TO LONG, rsp:PTR TO LONG
  13.  
  14. RAISE "^C" IF CtrlC()=TRUE
  15.  
  16. PROC main() HANDLE
  17.   con:=Open('CON:0/11/640/100/TinyForth',1005)
  18.   IF con
  19.     stdout:=con
  20.     WriteF('TinyForth interpreter v0.1 (c) 1992 by $#%!\n')
  21.     sp:=stack; rsp:=rstack
  22.     REPEAT
  23.       IF crflag=FALSE THEN WriteF('\n')
  24.       SELECT error
  25.         CASE OK;           WriteF('Ok.\n')
  26.         CASE ER_UNDERFLOW; WriteF('STACK UNDERFLOW.\n')
  27.         CASE ER_OVERFLOW;  WriteF('STACK OVERFLOW.\n')
  28.         CASE ER_SYM;       WriteF('\s?\n',item)
  29.       ENDSELECT
  30.       WriteF('>')
  31.       ReadStr(con,inp)
  32.       CtrlC()
  33.       error:=OK; crflag:=TRUE
  34.       eval(inp)
  35.     UNTIL stop
  36.   ENDIF
  37. EXCEPT DO
  38.   IF con THEN Close(con)
  39. ENDPROC
  40.  
  41. PROC eval(c)
  42.   DEF pos,end,symlong,p,i,j,k
  43.   pos:=c; end:=c+EstrLen(c)
  44.   WHILE (pos<end) AND (error<=OK)
  45.     CtrlC()
  46.     pos:=getsym(pos)
  47.     StrCopy(item2,item,ALL)
  48.     UpperStr(item2)
  49.     StrAdd(item2,'   ',3)
  50.     symlong:=Long(item2)
  51.     SELECT symlong
  52.       CASE "DUP "; i:=pop(); push(i); push(i)
  53.       CASE "DROP"; pop()
  54.       CASE "SWAP"; i:=pop(); j:=pop(); push(i); push(j)
  55.       CASE "OVER"; i:=pop(); j:=pop(); push(j); push(i); push(j)
  56.       CASE "ROT "; i:=pop(); j:=pop(); k:=pop(); push(j); push(i); push(k)
  57.       CASE "PICK"; i:=pop(); IF sp-(i*4)<stack THEN error:=ER_UNDERFLOW ELSE push(sp[-i])
  58.       CASE "ROLL"; i:=pop(); j:=sp[-i]; IF sp-(i*4)<stack THEN error:=ER_UNDERFLOW ELSE FOR k:=-i TO -2 DO sp[k]:=sp[k+1]; pop(); push(j)
  59.       CASE "?DUP"; i:=pop(); push(i); IF i THEN push(i)
  60.       CASE "DEPT"; push(sp-stack/4)
  61.       CASE ">R  "; rpush(pop())
  62.       CASE "R>  "; push(rpop())
  63.       CASE "R@  "; i:=rpop(); push(i); rpush(i)
  64.  
  65.       CASE "<   "; push(Not(pop()<=pop()))
  66.       CASE "=   "; push(pop()=pop())
  67.       CASE ">   "; push(Not(pop()>=pop()))
  68.       CASE "0<  "; push(pop()<0)
  69.       CASE "0=  "; push(0=pop())
  70.       CASE "0>  "; push(pop()>0)
  71.       CASE "D<  "; push(Not(pop()<=pop()))
  72.       CASE "U<  "; push(Not(pop()<=pop()))
  73.       CASE "NOT "; push(Not(pop()))
  74.  
  75.       CASE ".   "; WriteF('\d ',pop()); crflag:=FALSE
  76.       CASE "CR  "; WriteF('\n'); crflag:=TRUE
  77.       CASE "EMIT"; WriteF('\c',pop()); crflag:=FALSE
  78.       CASE "TYPE"; i:=pop(); j:=pop(); FOR k:=1 TO i DO WriteF('\c',j[]++)
  79.       CASE "SPAC"; IF Long(item2+4)="E   " THEN i:=1 ELSE i:=pop(); FOR j:=1 TO i DO WriteF(' '); crflag:=FALSE
  80.  
  81.       CASE "+   "; push(pop()+pop())
  82.       CASE "-   "; i:=pop(); push(pop()-i)
  83.       CASE "*   "; push(Mul(pop(),pop()))
  84.       CASE "/   "; i:=pop(); push(Div(pop(),i))
  85.  
  86.       CASE "ABOR"; sp:=stack
  87.       CASE "QUIT"; stop:=TRUE
  88.       DEFAULT
  89.         IF Int(item)=$2E22      /* ." construction */
  90.           crflag:=FALSE
  91.           Write(stdout,item+2,EstrLen(item)-3)
  92.         ELSE
  93.           IF item[0]="-" THEN p:=item+1 ELSE p:=item
  94.           i:=Val(p,{j})
  95.           IF (j=0) THEN error:=ER_SYM
  96.           IF p<>item THEN i:=Mul(i,-1)
  97.           push(i)
  98.        ENDIF
  99.     ENDSELECT
  100.   ENDWHILE
  101. ENDPROC
  102.  
  103. PROC pop() RETURN IF sp<=stack THEN error:=ER_UNDERFLOW ELSE sp[]--
  104. PROC rpop() RETURN IF rsp<=rstack THEN error:=ER_UNDERFLOW ELSE rsp[]--
  105. PROC push(val); IF MAXSTACK*4+stack<=sp THEN error:=ER_OVERFLOW ELSE sp[]++:=val; ENDPROC
  106. PROC rpush(val); IF MAXRSTACK*4+rstack<=rsp THEN error:=ER_OVERFLOW ELSE rsp[]++:=val; ENDPROC
  107.  
  108. PROC getsym(p)
  109.   DEF p2
  110.   p:=TrimStr(p)
  111.   IF p[0]="("
  112.     p2:=InStr(p,')',0)
  113.     IF p2=-1 THEN p2:=1000
  114.     p:=TrimStr(p+p2+1)
  115.   ENDIF
  116.   IF p[0]="." AND p[1]=34
  117.     p2:=InStr(p,'"',2)
  118.     IF p2=-1 THEN p2:=1000 ELSE INC p2
  119.     StrCopy(item,p,p2)
  120.   ELSE
  121.     p2:=InStr(p,' ',0)
  122.     IF p2=-1 THEN p2:=1000
  123.     StrCopy(item,p,p2)
  124.   ENDIF
  125. ENDPROC p+p2+1
  126.